home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / sources.lha / sources / comp / back_end / m68rep.t < prev    next >
Encoding:
Text File  |  1988-02-05  |  19.1 KB  |  543 lines
  1. (herald (back_end m68rep)
  2.   (env t (orbit_top defs) (back_end bookkeep)))
  3.  
  4. ;;; Copyright (c) 1985 Yale University
  5. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  6. ;;; This material was developed by the T Project at the Yale University Computer 
  7. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  8. ;;; and to use it for any purpose is granted, subject to the following restric-
  9. ;;; tions and understandings.
  10. ;;; 1. Any copy made of this software must include this copyright notice in full.
  11. ;;; 2. Users of this software agree to make their best efforts (a) to return
  12. ;;;    to the T Project at Yale any improvements or extensions that they make,
  13. ;;;    so that these may be included in future releases; and (b) to inform
  14. ;;;    the T Project of noteworthy uses of this software.
  15. ;;; 3. All materials developed as a consequence of the use of this software
  16. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  17. ;;;    of acknowledging credit in academic research.
  18. ;;; 4. Yale has made no warrantee or representation that the operation of
  19. ;;;    this software will be error-free, and Yale is under no obligation to
  20. ;;;    provide any services, by way of maintenance, update, or otherwise.
  21. ;;; 5. In conjunction with products arising from the use of this material,
  22. ;;;    there shall be no use of the name of the Yale University nor of any
  23. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  24. ;;;    without prior written consent from Yale in each case.
  25. ;;;
  26. (define (rep-analyze-top node)
  27.   (rep-analyze ((call-arg 1) (lambda-body node)))
  28.   (rep-analyze ((call-arg 1) (lambda-body node))))
  29.  
  30. (define (rep-analyze node)
  31.   (cond ((lambda-node? node)
  32.          (rep-analyze-call (lambda-body node))
  33.          (select (lambda-strategy node)
  34.            ((strategy/label strategy/open) 
  35.             (walk (lambda (var)
  36.                     (or (eq? (variable-type var) type/top)
  37.                         (neq? (variable-rep var) 'rep/pointer)
  38.                         (set (variable-rep var) (most-important-rep var))))
  39.                   (if (continuation? node)
  40.                       (lambda-variables node)
  41.                       (cdr (lambda-variables node)))))))))
  42.  
  43.  
  44. (define (rep-analyze-call node)
  45.   (let ((proc (call-proc node)))
  46.     (cond ((lambda-node? proc)
  47.            (walk rep-analyze (call-args node))
  48.            (rep-analyze-call (lambda-body proc)))
  49.       ((not (primop-node? proc))
  50.            (walk rep-analyze (call-args node)))
  51.           ((eq? (primop-value proc) primop/Y)
  52.            (rep-analyze ((call-arg 1) node))
  53.            (destructure (((body . procs) 
  54.                           (call-args (lambda-body ((call-arg 2) node)))))
  55.              (walk rep-analyze procs)
  56.              (rep-analyze body)))
  57.           (else
  58.        (walk rep-analyze (call-args node))
  59.        (cond ((and (eq? (primop-value proc) primop/contents-location)
  60.                (lambda-node? ((call-arg 1) node))
  61.                (eq? (variable-rep (lambda-cont-var ((call-arg 1) node)))
  62.                 'rep/pointer))
  63.           (set (variable-rep (lambda-cont-var ((call-arg 1) node)))
  64.                (primop.rep-wants (leaf-value ((call-arg 2) node))))))))))
  65.  
  66.  
  67. (define (most-important-rep var)
  68.   (iterate loop ((refs (variable-refs var)) (reps '()))
  69.     (cond ((null? refs) 
  70.            (select-rep (reverse! reps) (variable-type var)))
  71.           (else
  72.            (let* ((parent (node-parent (car refs)))
  73.                   (proc (call-proc parent))
  74.                   (number (call-arg-number (node-role (car refs)))))
  75.              (cond ((primop-node? proc)
  76.                     (cond ((primop.rep-wants (primop-value proc))
  77.                            => (lambda (creps)
  78.                 (let ((rep 
  79.                        (nth creps (fx- (fx- number
  80.                                                     (call-exits parent))
  81.                                  1))))
  82.                   (if (neq? rep '*)
  83.                       (loop (cdr refs) (cons rep reps))
  84.                       (let ((cont ((call-arg 1) parent)))
  85.                     (loop (cdr refs)
  86.                           (if (leaf-node? cont)
  87.                           (cons 'rep/pointer reps)
  88.                           (let ((rep (variable-rep
  89.                              (lambda-cont-var cont))))
  90.                         (cons (if (eq? (rep-size rep) 4)
  91.                               rep
  92.                               'rep/integer)
  93.                           reps)))))))))
  94.                           ((eq? (primop-value proc) primop/contents-location)
  95.                (loop (cdr refs)
  96.                  (cons
  97.                            (if (and (fx= number 4) 
  98.                                     (fx< (rep-size (primop.rep-wants
  99.                                              (leaf-value ((call-arg 2) parent))))
  100.                                           size/long))
  101.                                'rep/integer 'rep/pointer)
  102.                reps)))
  103.                           ((eq? (primop-value proc) primop/set-location)
  104.                (loop (cdr refs)
  105.                  (cons 
  106.                            (cond ((and (fx= number 5)
  107.                                        (fx< (rep-size (primop.rep-wants
  108.                                                (leaf-value ((call-arg 2) parent))))
  109.                                             size/long))
  110.                                   'rep/integer)
  111.                                  ((fx= number 3)
  112.                                   (primop.rep-wants 
  113.                                       (leaf-value ((call-arg 2) parent))))
  114.                                  (else 'rep/pointer))
  115.                reps)))
  116.                           (else 
  117.                            (loop (cdr refs) reps))))
  118.                    ((variable-known (leaf-value proc)) 
  119.                     => (lambda (label)
  120.                          (cond ((lambda-rest-var label) 
  121.                                 (loop (cdr refs) reps))
  122.                                (else
  123.                 (loop (cdr refs)
  124.                       (cons (variable-rep (nth (lambda-variables label)
  125.                                    (fx- number 1)))
  126.                         reps))))))
  127.                    (else
  128.                     (loop (cdr refs) (cons 'rep/pointer reps)))))))))
  129.  
  130. (define (select-rep reps type)
  131.   (cond ((null? reps)
  132.      'rep/pointer)
  133.     ((eq? type type/char)
  134.      (car reps))
  135.     (else
  136.      (let ((size (rep-size (car reps))))
  137.        (iterate loop ((r (cdr reps)))
  138.          (cond ((null? r) (car reps))
  139.            ((fx= (rep-size (car r)) size)
  140.             (loop (cdr r)))
  141.            (else
  142.             (car (sort-list! reps (lambda (x y)
  143.                         (fx> (rep-size x) (rep-size y))))))))))))
  144.  
  145.  
  146. (define (access-with-rep node value rep)
  147.   (access-with-rep-reg node value rep nil))
  148.  
  149. (define (access-with-rep-reg node value rep reg)
  150.   (cond ((variable? value)
  151.          (let ((acc (access-value node value)))
  152.            (cond ((rep-converter (variable-rep value) rep)
  153.                   => (lambda (converter)
  154.                        (let* ((rep-type (if (eq? rep 'rep/pointer) 'pointer 'scratch))
  155.                               (reg (cond ((and (register? acc) 
  156.                                                (eq? (reg-type acc) rep-type)
  157.                                                (dying? value node))
  158.                                             acc)
  159.                                          ((and (register? reg) 
  160.                                                (not (reg-node reg))
  161.                                                (eq? (reg-type reg) rep-type))
  162.                                           reg)
  163.                                          (else 
  164.                                           (get-register rep-type node '*)))))
  165.                          (converter node acc reg)
  166.                          reg)))
  167.                  (else acc))))
  168.         ((eq? rep 'rep/pointer)
  169.          (access-value node value))
  170.         (else
  171.          (value-with-rep value rep))))
  172.  
  173. (lset *reps* '(rep/char
  174.                rep/extend
  175.                rep/integer
  176.                rep/integer-8-s
  177.                rep/integer-8-u
  178.                rep/integer-16-s
  179.                rep/integer-16-u
  180.                rep/string
  181.                rep/pointer))
  182.                                       
  183. (define-constant size/byte 1)
  184. (define-constant size/word 2)
  185. (define-constant size/long 4)
  186.  
  187.  
  188. (lset *rep-converter-table* (make-table 'reps))
  189.                    
  190. (walk (lambda (rep)
  191.         (set (table-entry *rep-converter-table* rep) 
  192.              (make-table rep)))
  193.       *reps*)
  194.  
  195. (define (rep-size rep)
  196.   (case rep
  197.     ((rep/char rep/integer-8-u rep/integer-8-s) size/byte)
  198.     ((rep/integer-16-u rep/integer-16-s) size/word)
  199.     (else size/long)))
  200.  
  201.  
  202.  
  203. (define-local-syntax (define-rep-converter from to proc)
  204.   `(set (table-entry (table-entry *rep-converter-table* ',to) ',from)
  205.         ,proc))
  206.  
  207.  
  208. (define-rep-converter rep/pointer rep/extend
  209.   (lambda (node from to)
  210.     (generate-move from to)
  211.     (emit m68/add .l (machine-num tag/extend) to)))
  212.  
  213. (define-rep-converter rep/extend rep/pointer
  214.   (lambda (node from to)
  215.     (generate-move from to)
  216.     (emit m68/sub .l (machine-num tag/extend) to)))
  217.                    
  218. (define-rep-converter rep/pointer rep/string
  219.   (lambda (node from to)             
  220.     (let ((reg (cond ((register? from) from)
  221.                      (else
  222.                       (generate-move from AN)
  223.                       AN)))) 
  224.       (emit m68/move .l (reg-offset reg offset/string-text) S0)
  225.       (emit m68/add .l (reg-offset reg offset/string-base) S0)
  226.       (emit m68/add .l (machine-num tag/extend) S0)
  227.       (emit m68/move .l S0 to))))
  228.  
  229. (define-rep-converter rep/pointer rep/char
  230.    (lambda (node from to)
  231.      (cond ((register? to)
  232.             (generate-move from to)
  233.             (emit m68/lsr .w (machine-num 8) to))
  234.            (else
  235.             (emit m68/move .l from SCRATCH)
  236.             (emit m68/lsr .w (machine-num 8) SCRATCH)
  237.             (emit m68/move .b SCRATCH to)))))
  238.  
  239.  
  240. (define-rep-converter rep/pointer rep/integer
  241.   (lambda (node from to)                    
  242.     (cond ((register? to)
  243.            (generate-move from to)
  244.            (emit m68/asr .l (machine-num 2) to))
  245.           (else
  246.            (emit m68/move .l from SCRATCH)
  247.            (emit m68/asr .l (machine-num 2) SCRATCH)
  248.            (emit m68/move .l SCRATCH to)))))
  249.  
  250. (define (pointer->integer-16 node from to)
  251.     (cond ((register? to)
  252.            (generate-move from to)
  253.            (emit m68/asr .l (machine-num 2) to))
  254.           (else
  255.            (emit m68/move .l from SCRATCH)
  256.            (emit m68/asr .l (machine-num 2) SCRATCH)
  257.            (emit m68/move .w SCRATCH to))))
  258.  
  259.  
  260. (define-rep-converter rep/pointer rep/integer-16-u
  261.   pointer->integer-16)
  262.  
  263. (define-rep-converter rep/pointer rep/integer-16-s
  264.   pointer->integer-16)
  265.  
  266. (define (pointer->integer-8 node from to)
  267.     (cond ((register? to)
  268.            (generate-move from to)
  269.            (emit m68/asr .w (machine-num 2) to))
  270.           (else
  271.            (emit m68/move .l from SCRATCH)
  272.            (emit m68/asr .w (machine-num 2) SCRATCH)
  273.            (emit m68/move .b SCRATCH to))))
  274.  
  275.  
  276.  
  277. (define-rep-converter rep/pointer rep/integer-8-u
  278.   pointer->integer-8)
  279.  
  280. (define-rep-converter rep/pointer rep/integer-8-s
  281.   pointer->integer-8)
  282.  
  283. ;------------------------------------------------------------------------------
  284.                  
  285. (define (integer->integer-16 node from to)
  286.     (cond ((register? from)
  287.            (emit m68/move .w from to))
  288.           ((fixnum? from)
  289.            (emit m68/move .w 
  290.                  (d@r 14 (fx+ (fx* (fx- from *real-registers*) CELL) 2)) to))
  291.           (else
  292.            (emit m68/move .w (reg-offset (car from) (fx+ (cdr from) 2)) to))))
  293.  
  294.  
  295. (define-rep-converter rep/integer rep/integer-16-u
  296.   integer->integer-16)
  297.  
  298. (define-rep-converter rep/integer rep/integer-16-s
  299.   integer->integer-16)
  300.  
  301. (define (integer->integer-8 node from to)
  302.     (cond ((register? from)
  303.            (emit m68/move .b from to))
  304.           ((fixnum? from)
  305.            (emit m68/move .b 
  306.                  (d@r 14 (fx+ (fx* (fx- from *real-registers*) CELL) 3)) to))
  307.           (else
  308.            (emit m68/move .b (reg-offset (car from) (fx+ (cdr from) 3)) to))))
  309.  
  310.  
  311. (define-rep-converter rep/integer rep/integer-8-u
  312.   integer->integer-8)
  313.  
  314. (define-rep-converter rep/integer rep/integer-8-s
  315.   integer->integer-8)
  316.  
  317. (define (integer-16->integer-8 node from to)
  318.     (cond ((register? from)
  319.            (emit m68/move .b from to))
  320.           ((fixnum? from)
  321.            (emit m68/move .b 
  322.                  (d@r 14 (fx+ (fx* (fx- from *real-registers*) CELL) 1)) to))
  323.           (else
  324.            (emit m68/move .b (reg-offset (car from) (fx+ (cdr from) 1)) to))))
  325.  
  326.  
  327. (define-rep-converter rep/integer-16-u rep/integer-8-u
  328.   integer-16->integer-8)
  329.  
  330. (define-rep-converter rep/integer-16-u rep/integer-8-s
  331.   integer-16->integer-8)
  332.  
  333. (define-rep-converter rep/integer-16-s rep/integer-8-u
  334.   integer-16->integer-8)
  335.  
  336. (define-rep-converter rep/integer-16-s rep/integer-8-s
  337.   integer-16->integer-8)
  338.  
  339.  
  340. ;----------------------------
  341.  
  342. (define-rep-converter rep/char rep/pointer
  343.   (lambda (node from to)
  344.     (let ((temp (if (and (register? to) (eq? (reg-type to) 'scratch))
  345.                     to
  346.                     SCRATCH)))
  347.       (emit m68/move .b from temp)
  348.       (emit m68/and .l (machine-num #xff) temp)
  349.       (emit m68/asl .w (machine-num 8) temp)
  350.       (emit m68/move .b (machine-num header/char) temp)
  351.       (generate-move temp to))))
  352.                               
  353.  
  354. ;-----------------------------
  355.                                                    
  356. (define-rep-converter rep/integer rep/pointer
  357.   (lambda (node from to)
  358.     (let ((reg (if (and (register? to) (eq? (reg-type to) 'scratch))
  359.                    to
  360.                    SCRATCH)))
  361.       (generate-move from reg)
  362.       (emit m68/asl .l (machine-num 2) reg)
  363.       (generate-move reg to))))
  364.  
  365. ;--------------------------------
  366.  
  367. (define-rep-converter rep/integer-16-s rep/pointer
  368.   (lambda (node from to)
  369.     (let ((reg (if (and (register? to) (eq? (reg-type to) 'scratch))
  370.                    to
  371.                    SCRATCH)))
  372.       (generate-move-word from reg)
  373.       (emit m68/ext .l reg)
  374.       (emit m68/asl .l (machine-num 2) reg)
  375.       (generate-move reg to))))
  376.  
  377. (define-rep-converter rep/integer-16-s rep/integer
  378.   (lambda (node from to)
  379.     (let ((reg (if (and (register? to) (eq? (reg-type to) 'scratch))
  380.                    to
  381.                    SCRATCH)))
  382.       (generate-move-word from reg)
  383.       (emit m68/ext .l reg)
  384.       (generate-move reg to))))
  385.  
  386. ;----------------------------------
  387.  
  388. (define-rep-converter rep/integer-16-u rep/pointer
  389.   (lambda (node from to)
  390.     (let ((reg (if (and (register? to) (eq? (reg-type to) 'scratch))
  391.                    to
  392.                    SCRATCH)))
  393.       (generate-move-word from reg)
  394.       (emit m68/and .l (machine-num #xFFFF) reg)
  395.       (emit m68/asl .l (machine-num 2) reg)
  396.       (generate-move reg to))))
  397.  
  398. (define-rep-converter rep/integer-16-u rep/integer
  399.   (lambda (node from to)
  400.     (let ((reg (if (and (register? to) (eq? (reg-type to) 'scratch))
  401.                    to
  402.                    SCRATCH)))
  403.       (generate-move-word from reg)
  404.       (emit m68/and .l (machine-num #xFFFF) reg)
  405.       (generate-move reg to))))
  406.  
  407. ;------------------------------------
  408.  
  409. (define-rep-converter rep/integer-8-s rep/pointer
  410.   (lambda (node from to)
  411.     (let ((reg (if (and (register? to) (eq? (reg-type to) 'scratch))
  412.                    to
  413.                    SCRATCH)))
  414.       (generate-move-byte from reg)
  415.       (emit m68/ext .w reg)
  416.       (emit m68/ext .l reg)
  417.       (emit m68/asl .l (machine-num 2) reg)
  418.       (generate-move reg to))))
  419.  
  420. (define-rep-converter rep/integer-8-s rep/integer
  421.   (lambda (node from to)
  422.     (let ((reg (if (and (register? to) (eq? (reg-type to) 'scratch))
  423.                    to
  424.                    SCRATCH)))
  425.       (generate-move-byte from reg)
  426.       (emit m68/ext .w reg)
  427.       (emit m68/ext .l reg)
  428.       (generate-move reg to))))
  429.  
  430. (define (integer-8-s->integer-16 node from to)
  431.     (let ((reg (if (and (register? to) (eq? (reg-type to) 'scratch))
  432.                    to
  433.                    SCRATCH)))
  434.       (generate-move-byte from reg)
  435.       (emit m68/ext .w reg)
  436.       (generate-move-word reg to)))
  437.  
  438. (define-rep-converter rep/integer-8-s rep/integer-16-s
  439.   integer-8-s->integer-16)
  440.  
  441. (define-rep-converter rep/integer-8-s rep/integer-16-u
  442.   integer-8-s->integer-16)
  443.                                      
  444. ;---------------------------------------
  445.  
  446.  
  447. (define-rep-converter rep/integer-8-u rep/pointer
  448.   (lambda (node from to)
  449.     (let ((reg (if (and (register? to) (eq? (reg-type to) 'scratch))
  450.                    to
  451.                    SCRATCH)))
  452.       (generate-move-byte from reg)
  453.       (emit m68/and .l (machine-num #xFF) reg)
  454.       (emit m68/asl .l (machine-num 2) reg)
  455.       (generate-move reg to))))
  456.  
  457. (define-rep-converter rep/integer-8-u rep/integer
  458.   (lambda (node from to)
  459.     (let ((reg (if (and (register? to) (eq? (reg-type to) 'scratch))
  460.                    to
  461.                    SCRATCH)))
  462.       (generate-move-byte from reg)
  463.       (emit m68/and .l (machine-num #xFF) reg)
  464.       (generate-move reg to))))
  465.  
  466. (define (integer-8-u->integer-16 node from to)
  467.     (let ((reg (if (and (register? to) (eq? (reg-type to) 'scratch))
  468.                    to
  469.                    SCRATCH)))
  470.       (generate-move-byte from reg)
  471.       (emit m68/and .w (machine-num #xFF) reg)
  472.       (generate-move-word reg to)))
  473.  
  474. (define-rep-converter rep/integer-8-u rep/integer-16-s
  475.   integer-8-u->integer-16)
  476.  
  477. (define-rep-converter rep/integer-8-u rep/integer-16-u
  478.   integer-8-u->integer-16)
  479.                   
  480. ;------------------------------------------
  481.  
  482. (define (rep-converter from-rep to-rep)
  483.   (table-entry (table-entry *rep-converter-table* to-rep) from-rep))
  484.  
  485.  
  486. (define (really-rep-convert node from from-rep to to-rep)
  487.   (cond ((rep-converter from-rep to-rep)
  488.          => (lambda (converter) (converter node from to)))
  489.         ((eq? to-rep 'rep/pointer)
  490.          (generate-move from to))
  491.         ((neq? from to)
  492.          (emit m68/move (m68-size to-rep) from to))))
  493.       
  494.  
  495.  
  496. (define (rep-push node value to-rep)
  497.   (cond ((addressable? value)
  498.          (select (rep-size to-rep) 
  499.            ((size/long)
  500.             (generate-push (value-with-rep value to-rep)))
  501.            ((size/word)
  502.             (emit m68/pea (@r 8))
  503.             (generate-move-word (value-with-rep value to-rep) (@r 15)))
  504.            ((size/byte)
  505.             (emit m68/pea (@r 8))
  506.             (generate-move-byte (value-with-rep value to-rep) (@r 15)))))
  507.         (else
  508.          (let ((access (access-value node value))
  509.                (from-rep (variable-rep value)))
  510.            (cond ((eq? from-rep to-rep)
  511.                   (generate-push access))
  512.                  ((eq? to-rep 'rep/extend)
  513.                   (emit m68/move .l access (@-r 15))
  514.                   (emit m68/add .l (machine-num tag/extend) (@r 15)))
  515.                  ((eq? to-rep 'rep/value)
  516.                   (generate-push access))
  517.                  ((neq? (rep-size to-rep) size/long)
  518.                   (emit m68/pea (@r 8))                                         
  519.                   (really-rep-convert node access from-rep (@r 15) to-rep))
  520.                  (else
  521.                   (really-rep-convert node access from-rep (@-r 15) to-rep))))))
  522.   (increment-stack))
  523.  
  524.  
  525. (define (value-with-rep value rep)
  526.   (xcond ((char? value)
  527.           (xcond ((eq? rep 'rep/char)
  528.                   (machine-num (char->ascii value)))
  529.                  ((eq? rep 'rep/pointer)
  530.                   (machine-num (fixnum-logior (fixnum-ashl (char->ascii value) 8)
  531.                                               header/char)))))
  532.          ((fixnum? value)
  533.           (cond ((eq? rep 'rep/pointer)
  534.                  (lit value))
  535.                 (else
  536.                  (machine-num value))))
  537.          ((eq? value '#T)
  538.           (machine-num header/true))
  539.          ((or (eq? value '#F) (eq? value '()))
  540.           nil-reg)))
  541.                 
  542.  
  543.